home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / gifpasse.zip / NGIF.PAS < prev    next >
Pascal/Delphi Source File  |  1989-02-27  |  11KB  |  411 lines
  1. unit ngif;
  2.  
  3.        { Steve Enns Feb.26 1989
  4.          Copyright 1989 Steve Enns   All rights reserved.
  5.          Synergrafix - Graphical and Numerical Software
  6.          2425 Haultain Ave. Saskatoon, Sask. Canada  S7J 1R2
  7.  
  8.          GIF ENcoding for BGI graphics
  9.          Must be in graphics mode before call
  10.  
  11.          This software is provided for unlimited use and
  12.          distribution EXCEPT for the following conditions:
  13.            - No fee is to be charged for the use or distribution
  14.              of this software, including any works which include
  15.              the source code or compiled form of this software.
  16.            - Any derived software or software which uses the source
  17.              code or compiled versions of this software must include
  18.              the source code of the derived software, and this notice.
  19.            - This software is to be distributed in the original
  20.              archived form, with the SAME name, GIFPASSE,
  21.              i.e. GIFPASSE.ZIP, GIFPASSE.ARC.
  22.  
  23.          This software is provided without warranty of any kind,
  24.          express or implied. YOU, the user assume complete
  25.          responsibility for any and all incidental or consequential
  26.          damages arising out of the use of this program. Use
  27.          at your own risk.
  28.  
  29.          This license is intended to encourage the distribution of
  30.          programs which include source code!
  31.  
  32.          'GIF' and 'Graphics Interchange Format' are trademarks
  33.           of Compuserve, Inc., an H&R Block Company. }
  34.  
  35. interface
  36.  
  37. const bigbitsmax=12;
  38.       hsizemax=5003;
  39.       maxcolarray=255;
  40.       masks :array[0..16] of longint=($0000,$0001,$0003,$0007,$000F,
  41.                                       $001F,$003F,$007F,$00FF,
  42.                                       $01FF,$03FF,$07FF,$0FFF,
  43.                                       $1FFF,$3FFF,$7FFF,$FFFF);
  44.  
  45. type colarray=array[0..maxcolarray] of integer;
  46.  
  47. var htab     :array[0..hsizemax-1] of longint;
  48.     codetab  :array[0..hsizemax-1] of integer;
  49.  
  50. Function engif(fname          :string; { filename for the GIF file }
  51.                startx,starty,          { upper left corner of image }
  52.                stopx,stopy    :integer;{ lower right corner of image }
  53.                colormap,               { TRUE for colormap }
  54.                interlace      :boolean;{ TRUE for interlace encoding }
  55.                background,             { background color index }
  56.                bitsperpixel   :integer;{ 1 shl bitsperpixel=numcolors }
  57.                red,green,blue :colarray{ color components for colormap }
  58.               ):boolean;               { returns FALSE for failure }
  59.  
  60. implementation
  61.  
  62. uses dos,                    { REGISTERS, MSDOS }
  63.      graph;                  { PUTPIXEL, GETPIXEL }
  64.  
  65. {$R-,S-}                     { Speed }
  66. { DEFINE SHOWPROGRESS}       { To erase pixels as they are read }
  67.  
  68. Function engif(fname          :string;
  69.                startx,starty,
  70.                stopx,stopy    :integer;
  71.                colormap,
  72.                interlace      :boolean;
  73.                background,
  74.                bitsperpixel   :integer;
  75.                red,green,blue :colarray):boolean;
  76.  
  77. var ioerror                       :boolean;
  78.     width,height,rwidth,rheight,
  79.     leftofs,topofs,resolution,
  80.     colormapsize,initcodesize,
  81.     i,b,n_bits,maxbits,maxcode,
  82.     maxmaxcode,free_ent,exit_stat,
  83.     clear_flg,offset,clearcode,
  84.     eofcode,cur_bits,a_count,
  85.     curx,cury,pass,g_init_bits    :integer;
  86.     hsize,fsize,in_count,
  87.     out_count,countdown,cur_accum :longint;
  88.     accum                         :array[0..255] of char;
  89.     fp                            :text;
  90.  
  91. {$I-}
  92.  
  93. Procedure flush_char;
  94. var i:byte;
  95. begin
  96.    if a_count>0 then
  97.    begin
  98.       write(fp,chr(a_count));
  99.       for i:=0 to a_count-1 do
  100.          write(fp,accum[i]);
  101.       a_count:=0
  102.    end
  103. end;
  104.  
  105. Procedure char_out(c:integer);
  106. begin
  107.    accum[a_count]:=chr(c);
  108.    inc(a_count);
  109.    if a_count>=254 then
  110.       flush_char
  111. end;
  112.  
  113. Procedure output(code:longint);
  114. begin
  115.    cur_accum:=cur_accum and masks[ cur_bits ];
  116.    if cur_bits>0 then
  117.       cur_accum:=cur_accum or (code shl cur_bits)
  118.    else
  119.       cur_accum:=code;
  120.    inc(cur_bits,n_bits);
  121.    while cur_bits>=8 do
  122.    begin
  123.       char_out(cur_accum and $ff);
  124.       cur_accum:=cur_accum shr 8;
  125.       dec(cur_bits,8)
  126.    end;
  127.    if (free_ent>maxcode) or (clear_flg<>0) then
  128.    begin
  129.       if clear_flg<>0 then
  130.       begin
  131.          n_bits:=g_init_bits;
  132.          maxcode:={ maxcodef(n_bits); } (1 shl n_bits)-1;
  133.          clear_flg:=0;
  134.       end else
  135.       begin
  136.          inc(n_bits);
  137.          if n_bits=maxbits then
  138.             maxcode:=maxmaxcode
  139.          else
  140.             maxcode:={ maxcodef(n_bits) } (1 shl n_bits)-1
  141.       end
  142.    end;
  143.    if code=eofcode then
  144.    begin
  145.       while cur_bits>0 do
  146.       begin
  147.          char_out(cur_accum and $ff);
  148.      cur_accum:=cur_accum shr 8;
  149.      dec(cur_bits,8)
  150.       end;
  151.       flush_char;
  152.       flush(fp)
  153.    end
  154. end;
  155.  
  156. Procedure cl_hash(hsize:longint);      { reset code table }
  157. var i :word;
  158. begin
  159.    for i:=0 to hsize-1 do
  160.       htab[i]:=-1
  161. end;
  162.  
  163. Procedure cl_block;                    { table clear for block compress }
  164. begin
  165.    cl_hash(hsize);
  166.    free_ent:=clearcode+2;
  167.    clear_flg:=1;
  168.    output(clearcode)
  169. end;
  170.  
  171. Procedure putword(w:integer);
  172. begin
  173.    write(fp,chr(w and $ff));
  174.    write(fp,chr((w shr 8) and $ff))
  175. end;
  176.  
  177. Procedure setrawmode(handle:word);
  178. var regs :registers;
  179. begin
  180.    with regs do
  181.    begin
  182.       ax:=$4401;                       { Set the new device status }
  183.       bx:=handle;
  184.       dx:=dx and $00DF;                { Clear the RAW bit }
  185.       inc(dx,32);
  186.       msdos(regs)
  187.    end
  188. end;
  189.  
  190. Procedure bumppixel;
  191. begin
  192.    inc(curx);
  193.  
  194.    if curx>stopx then
  195.    begin
  196.       curx:=startx;
  197.       if not interlace then
  198.          inc(cury)
  199.       else
  200.       case pass of
  201.          0:begin
  202.               inc(cury,8);
  203.               if cury>=(stopy+1) then
  204.               begin
  205.                  inc(pass);
  206.                  cury:=4+starty
  207.               end;
  208.            end;
  209.          1:begin
  210.               inc(cury,8);
  211.               if cury>=(stopy+1) then
  212.               begin
  213.                  inc(pass);
  214.                  cury:=2+starty
  215.               end
  216.            end;
  217.          2:begin
  218.               inc(cury,4);
  219.               if cury>=(stopy+1) then
  220.               begin
  221.                  inc(pass);
  222.                  cury:=1+starty
  223.               end
  224.            end;
  225.          3:inc(cury,2)
  226.       end
  227.    end
  228. end;
  229.  
  230. Function gifnextpixel(var c:integer):integer;
  231. begin
  232.    if countdown=0 then
  233.    begin
  234.       c:=-1;
  235.       gifnextpixel:=-1
  236.    end else
  237.    begin
  238.       dec(countdown);
  239.       c:=getpixel(curx,cury);
  240.       gifnextpixel:=c;
  241. {$IFDEF SHOWPROGRESS}
  242.       putpixel(curx,cury,0);
  243. {$ENDIF}
  244.       bumppixel
  245.    end
  246. end;
  247.  
  248. Procedure compress(init_bits:integer);
  249. label loop,probe,nomatch;
  250. var fcode           :longint;
  251.     c,hshift,i,ent,
  252.     disp,hsize_reg  :integer;
  253. begin
  254.    i:=0;
  255.    g_init_bits:=init_bits;
  256.    offset:=0;
  257.    out_count:=0;
  258.    clear_flg:=0;
  259.    in_count:=1;
  260.    n_bits:=g_init_bits;
  261.    maxcode:={maxcodef(n_bits);} (1 shl n_bits)-1;
  262.    clearcode:=1 shl (init_bits-1);
  263.    eofcode:=clearcode+1;
  264.    free_ent:=clearcode+2;
  265.    a_count:=0;
  266.    ent:=gifnextpixel(c);
  267.    hshift:=0;
  268.    fcode:=hsize;
  269.    while fcode<65536 do
  270.    begin
  271.       fcode:=fcode*2;
  272.       inc(hshift)
  273.    end;
  274.    hshift:=8-hshift;                  { set hash code range bound }
  275.    hsize_reg:=hsize;
  276.    cl_hash(hsize_reg);                { clear hash table }
  277.    output(clearcode);
  278.  
  279.    while gifnextpixel(c)<>-1 do
  280.    begin
  281.       inc(in_count);
  282.       fcode:=(c shl maxbits)+ent;
  283.       i:=(c shl hshift) xor ent;       { xor hashing }
  284.       if htab[i]=fcode then
  285.       begin
  286.          ent:=codetab[i];
  287.          goto loop
  288.       end
  289.       else if htab[i]<0 then           { empty slot }
  290.               goto nomatch;
  291.       disp:=hsize_reg-i;             { secondary hash (after G. Knott) }
  292.       if i=0 then
  293.          disp:=1;
  294.       probe:
  295.       dec(i,disp);
  296.       if i<0 then
  297.          inc(i,hsize_reg);
  298.       if htab[i]=fcode then
  299.       begin
  300.          ent:=codetab[i];
  301.          goto loop
  302.       end;
  303.       if htab[i]>0 then
  304.          goto probe;
  305.       nomatch:
  306.       output(ent);
  307.       inc(out_count);
  308.       ent:=c;
  309.       if free_ent<maxmaxcode then
  310.       begin
  311.          codetab[i]:=free_ent;         { code -> hashtable }
  312.          inc(free_ent);
  313.          htab[i]:=fcode
  314.       end else
  315.          cl_block;
  316.       loop:
  317.    end;
  318.  
  319.    output(ent);
  320.    inc(out_count);
  321.    output(eofcode)
  322.  
  323. end;
  324.  
  325.  
  326. begin
  327.    maxbits:=bigbitsmax;
  328.    maxmaxcode:=1 shl bigbitsmax;
  329.    hsize:=hsizemax;
  330.    free_ent:=0;
  331.    exit_stat:=0;
  332.    clear_flg:=0;
  333.    in_count:=1;
  334.    out_count:=0;
  335.    cur_accum:=0;
  336.    cur_bits:=0;
  337.    colormapsize:=1 shl bitsperpixel;
  338.  
  339.    width:=stopx-startx+1;  {gwidth;}
  340.    height:=stopy-starty+1; {gheight;}
  341.  
  342.    rwidth:=width;
  343.    rheight:=height;
  344.  
  345.    leftofs:=0; topofs:=0;
  346.  
  347.    resolution:=bitsperpixel;
  348.    countdown:=round(width)*round(height);
  349.    pass:=0;
  350.    if bitsperpixel<=1 then
  351.       initcodesize:=2
  352.    else
  353.       initcodesize:=bitsperpixel;
  354.  
  355.    curx:=startx;
  356.    cury:=starty;
  357.  
  358.    assign(fp,fname);
  359.    rewrite(fp);
  360.    setrawmode(textrec(fp).handle);
  361.    ioerror:=(ioresult<>0);
  362.  
  363.    if not ioerror then
  364.    begin
  365.       write(fp,'GIF87a');
  366.       putword(rwidth);
  367.       putword(rheight);
  368.       if colormap then
  369.          b:=$80           { Yes, there is a color map }
  370.       else
  371.          b:=0;
  372.       b:=b or ((resolution - 1) shl 5);
  373.       b:=b or (bitsperpixel - 1);
  374.       write(fp,chr(b));
  375.       write(fp,chr(background));
  376.       write(fp,chr(0));
  377.       if colormap then
  378.          for i:=0 to colormapsize-1 do
  379.          begin
  380.             write(fp,chr(red[i]));
  381.             write(fp,chr(green[i]));
  382.             write(fp,chr(blue[i]))
  383.          end;
  384.       write(fp,',');
  385.       putword(leftofs);
  386.       putword(topofs);
  387.       putword(width);
  388.       putword(height);
  389.       if interlace then
  390.          write(fp,chr($40))
  391.       else
  392.          write(fp,chr(0));
  393.       write(fp,chr(initcodesize));
  394.  
  395.       compress(initcodesize+1);
  396.  
  397.       write(fp,chr(0));
  398.       write(fp,';');
  399.  
  400.       close(fp)
  401.    end;
  402.  
  403.    ioerror:=(ioresult<>0);
  404.    engif:=not ioerror
  405.  
  406. {$I+}
  407.  
  408. end;
  409.  
  410. begin
  411. end.